home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / gnus / nnmbox.el.z / nnmbox.el
Encoding:
Text File  |  1998-05-21  |  17.5 KB  |  553 lines
  1. ;;; nnmbox.el --- mail mbox access for Gnus
  2. ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;;     Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  6. ;; Keywords: news, mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;; For an overview of what the interface functions do, please see the
  28. ;; Gnus sources.
  29.  
  30. ;;; Code:
  31.  
  32. (require 'nnheader)
  33. (require 'message)
  34. (require 'nnmail)
  35. (require 'nnoo)
  36. (eval-when-compile (require 'cl))
  37.  
  38. (nnoo-declare nnmbox)
  39.  
  40. (defvoo nnmbox-mbox-file (expand-file-name "~/mbox")
  41.   "The name of the mail box file in the user's home directory.")
  42.  
  43. (defvoo nnmbox-active-file (expand-file-name "~/.mbox-active")
  44.   "The name of the active file for the mail box.")
  45.  
  46. (defvoo nnmbox-get-new-mail t
  47.   "If non-nil, nnmbox will check the incoming mail file and split the mail.")
  48.  
  49. (defvoo nnmbox-prepare-save-mail-hook nil
  50.   "Hook run narrowed to an article before saving.")
  51.  
  52.  
  53.  
  54. (defconst nnmbox-version "nnmbox 1.0"
  55.   "nnmbox version.")
  56.  
  57. (defvoo nnmbox-current-group nil
  58.   "Current nnmbox news group directory.")
  59.  
  60. (defconst nnmbox-mbox-buffer nil)
  61.  
  62. (defvoo nnmbox-status-string "")
  63.  
  64. (defvoo nnmbox-group-alist nil)
  65. (defvoo nnmbox-active-timestamp nil)
  66.  
  67.  
  68.  
  69. ;;; Interface functions
  70.  
  71. (nnoo-define-basics nnmbox)
  72.  
  73. (deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server fetch-old)
  74.   (save-excursion
  75.     (set-buffer nntp-server-buffer)
  76.     (erase-buffer)
  77.     (let ((number (length sequence))
  78.       (count 0)
  79.       article art-string start stop)
  80.       (nnmbox-possibly-change-newsgroup newsgroup server)
  81.       (while sequence
  82.     (setq article (car sequence))
  83.     (setq art-string (nnmbox-article-string article))
  84.     (set-buffer nnmbox-mbox-buffer)
  85.     (when (or (search-forward art-string nil t)
  86.           (progn (goto-char (point-min))
  87.              (search-forward art-string nil t)))
  88.       (setq start
  89.         (save-excursion
  90.           (re-search-backward
  91.            (concat "^" message-unix-mail-delimiter) nil t)
  92.           (point)))
  93.       (search-forward "\n\n" nil t)
  94.       (setq stop (1- (point)))
  95.       (set-buffer nntp-server-buffer)
  96.       (insert (format "221 %d Article retrieved.\n" article))
  97.       (insert-buffer-substring nnmbox-mbox-buffer start stop)
  98.       (goto-char (point-max))
  99.       (insert ".\n"))
  100.     (setq sequence (cdr sequence))
  101.     (setq count (1+ count))
  102.     (and (numberp nnmail-large-newsgroup)
  103.          (> number nnmail-large-newsgroup)
  104.          (zerop (% count 20))
  105.          (nnheader-message 5 "nnmbox: Receiving headers... %d%%"
  106.                    (/ (* count 100) number))))
  107.  
  108.       (and (numberp nnmail-large-newsgroup)
  109.        (> number nnmail-large-newsgroup)
  110.        (nnheader-message 5 "nnmbox: Receiving headers...done"))
  111.  
  112.       (set-buffer nntp-server-buffer)
  113.       (nnheader-fold-continuation-lines)
  114.       'headers)))
  115.  
  116. (deffoo nnmbox-open-server (server &optional defs)
  117.   (nnoo-change-server 'nnmbox server defs)
  118.   (nnmbox-create-mbox)
  119.   (cond
  120.    ((not (file-exists-p nnmbox-mbox-file))
  121.     (nnmbox-close-server)
  122.     (nnheader-report 'nnmbox "No such file: %s" nnmbox-mbox-file))
  123.    ((file-directory-p nnmbox-mbox-file)
  124.     (nnmbox-close-server)
  125.     (nnheader-report 'nnmbox "Not a regular file: %s" nnmbox-mbox-file))
  126.    (t
  127.     (nnheader-report 'nnmbox "Opened server %s using mbox %s" server
  128.              nnmbox-mbox-file)
  129.     t)))
  130.  
  131. (deffoo nnmbox-close-server (&optional server)
  132.   (when (and nnmbox-mbox-buffer
  133.          (buffer-name nnmbox-mbox-buffer))
  134.     (kill-buffer nnmbox-mbox-buffer))
  135.   (nnoo-close-server 'nnmbox server)
  136.   t)
  137.  
  138. (deffoo nnmbox-server-opened (&optional server)
  139.   (and (nnoo-current-server-p 'nnmbox server)
  140.        nnmbox-mbox-buffer
  141.        (buffer-name nnmbox-mbox-buffer)
  142.        nntp-server-buffer
  143.        (buffer-name nntp-server-buffer)))
  144.  
  145. (deffoo nnmbox-request-article (article &optional newsgroup server buffer)
  146.   (nnmbox-possibly-change-newsgroup newsgroup server)
  147.   (save-excursion
  148.     (set-buffer nnmbox-mbox-buffer)
  149.     (goto-char (point-min))
  150.     (when (search-forward (nnmbox-article-string article) nil t)
  151.       (let (start stop)
  152.     (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
  153.     (setq start (point))
  154.     (forward-line 1)
  155.     (or (and (re-search-forward
  156.           (concat "^" message-unix-mail-delimiter) nil t)
  157.          (forward-line -1))
  158.         (goto-char (point-max)))
  159.     (setq stop (point))
  160.     (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
  161.       (set-buffer nntp-server-buffer)
  162.       (erase-buffer)
  163.       (insert-buffer-substring nnmbox-mbox-buffer start stop)
  164.       (goto-char (point-min))
  165.       (while (looking-at "From ")
  166.         (delete-char 5)
  167.         (insert "X-From-Line: ")
  168.         (forward-line 1))
  169.       (if (numberp article)
  170.           (cons nnmbox-current-group article)
  171.         (nnmbox-article-group-number)))))))
  172.  
  173. (deffoo nnmbox-request-group (group &optional server dont-check)
  174.   (let ((active (cadr (assoc group nnmbox-group-alist))))
  175.     (cond
  176.      ((or (null active)
  177.       (null (nnmbox-possibly-change-newsgroup group server)))
  178.       (nnheader-report 'nnmbox "No such group: %s" group))
  179.      (dont-check
  180.       (nnheader-report 'nnmbox "Selected group %s" group)
  181.       (nnheader-insert ""))
  182.      (t
  183.       (nnheader-report 'nnmbox "Selected group %s" group)
  184.       (nnheader-insert "211 %d %d %d %s\n"
  185.                (1+ (- (cdr active) (car active)))
  186.                (car active) (cdr active) group)))))
  187.  
  188. (deffoo nnmbox-request-scan (&optional group server)
  189.   (nnmbox-possibly-change-newsgroup group server)
  190.   (nnmbox-read-mbox)
  191.   (nnmail-get-new-mail
  192.    'nnmbox
  193.    (lambda ()
  194.      (save-excursion
  195.        (set-buffer nnmbox-mbox-buffer)
  196.        (save-buffer)))
  197.    (file-name-directory nnmbox-mbox-file)
  198.    group
  199.    (lambda ()
  200.      (save-excursion
  201.        (let ((in-buf (current-buffer)))
  202.      (set-buffer nnmbox-mbox-buffer)
  203.      (goto-char (point-max))
  204.      (insert-buffer-substring in-buf)))
  205.      (nnmail-save-active nnmbox-group-alist nnmbox-active-file))))
  206.  
  207. (deffoo nnmbox-close-group (group &optional server)
  208.   t)
  209.  
  210. (deffoo nnmbox-request-list (&optional server)
  211.   (save-excursion
  212.     (nnmail-find-file nnmbox-active-file)
  213.     (setq nnmbox-group-alist (nnmail-get-active))
  214.     t))
  215.  
  216. (deffoo nnmbox-request-newgroups (date &optional server)
  217.   (nnmbox-request-list server))
  218.  
  219. (deffoo nnmbox-request-list-newsgroups (&optional server)
  220.   (nnheader-report 'nnmbox "LIST NEWSGROUPS is not implemented."))
  221.  
  222. (deffoo nnmbox-request-expire-articles
  223.   (articles newsgroup &optional server force)
  224.   (nnmbox-possibly-change-newsgroup newsgroup server)
  225.   (let* ((is-old t)
  226.      rest)
  227.     (nnmail-activate 'nnmbox)
  228.  
  229.     (save-excursion
  230.       (set-buffer nnmbox-mbox-buffer)
  231.       (while (and articles is-old)
  232.     (goto-char (point-min))
  233.     (when (search-forward (nnmbox-article-string (car articles)) nil t)
  234.       (if (setq is-old
  235.             (nnmail-expired-article-p
  236.              newsgroup
  237.              (buffer-substring
  238.               (point) (progn (end-of-line) (point))) force))
  239.           (progn
  240.         (nnheader-message 5 "Deleting article %d in %s..."
  241.                   (car articles) newsgroup)
  242.         (nnmbox-delete-mail))
  243.         (push (car articles) rest)))
  244.     (setq articles (cdr articles)))
  245.       (save-buffer)
  246.       ;; Find the lowest active article in this group.
  247.       (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist))))
  248.     (goto-char (point-min))
  249.     (while (and (not (search-forward
  250.               (nnmbox-article-string (car active)) nil t))
  251.             (<= (car active) (cdr active)))
  252.       (setcar active (1+ (car active)))
  253.       (goto-char (point-min))))
  254.       (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
  255.       (nconc rest articles))))
  256.  
  257. (deffoo nnmbox-request-move-article
  258.   (article group server accept-form &optional last)
  259.   (let ((buf (get-buffer-create " *nnmbox move*"))
  260.     result)
  261.     (and
  262.      (nnmbox-request-article article group server)
  263.      (save-excursion
  264.        (set-buffer buf)
  265.        (buffer-disable-undo (current-buffer))
  266.        (erase-buffer)
  267.        (insert-buffer-substring nntp-server-buffer)
  268.        (goto-char (point-min))
  269.        (while (re-search-forward
  270.            "^X-Gnus-Newsgroup:"
  271.            (save-excursion (search-forward "\n\n" nil t) (point)) t)
  272.      (delete-region (progn (beginning-of-line) (point))
  273.             (progn (forward-line 1) (point))))
  274.        (setq result (eval accept-form))
  275.        (kill-buffer buf)
  276.        result)
  277.      (save-excursion
  278.        (nnmbox-possibly-change-newsgroup group server)
  279.        (set-buffer nnmbox-mbox-buffer)
  280.        (goto-char (point-min))
  281.        (when (search-forward (nnmbox-article-string article) nil t)
  282.      (nnmbox-delete-mail))
  283.        (and last (save-buffer))))
  284.     result))
  285.  
  286. (deffoo nnmbox-request-accept-article (group &optional server last)
  287.   (nnmbox-possibly-change-newsgroup group server)
  288.   (nnmail-check-syntax)
  289.   (let ((buf (current-buffer))
  290.     result)
  291.     (goto-char (point-min))
  292.     ;; The From line may have been quoted by movemail.
  293.     (when (looking-at (concat ">" message-unix-mail-delimiter))
  294.       (delete-char 1))
  295.     (if (looking-at "X-From-Line: ")
  296.     (replace-match "From ")
  297.       (insert "From nobody " (current-time-string) "\n"))
  298.     (and
  299.      (nnmail-activate 'nnmbox)
  300.      (progn
  301.        (set-buffer buf)
  302.        (goto-char (point-min))
  303.        (search-forward "\n\n" nil t)
  304.        (forward-line -1)
  305.        (while (re-search-backward "^X-Gnus-Newsgroup: " nil t)
  306.      (delete-region (point) (progn (forward-line 1) (point))))
  307.        (when nnmail-cache-accepted-message-ids
  308.      (nnmail-cache-insert (nnmail-fetch-field "message-id")))
  309.        (setq result (if (stringp group)
  310.             (list (cons group (nnmbox-active-number group)))
  311.               (nnmail-article-group 'nnmbox-active-number)))
  312.        (if (and (null result)
  313.         (yes-or-no-p "Moved to `junk' group; delete article? "))
  314.        (setq result 'junk)
  315.      (setq result (car (nnmbox-save-mail result)))))
  316.      (save-excursion
  317.        (set-buffer nnmbox-mbox-buffer)
  318.        (goto-char (point-max))
  319.        (insert-buffer-substring buf)
  320.        (when last
  321.      (when nnmail-cache-accepted-message-ids
  322.        (nnmail-cache-close))
  323.      (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
  324.      (save-buffer))))
  325.     result))
  326.  
  327. (deffoo nnmbox-request-replace-article (article group buffer)
  328.   (nnmbox-possibly-change-newsgroup group)
  329.   (save-excursion
  330.     (set-buffer nnmbox-mbox-buffer)
  331.     (goto-char (point-min))
  332.     (if (not (search-forward (nnmbox-article-string article) nil t))
  333.     nil
  334.       (nnmbox-delete-mail t t)
  335.       (insert-buffer-substring buffer)
  336.       (save-buffer)
  337.       t)))
  338.  
  339. (deffoo nnmbox-request-delete-group (group &optional force server)
  340.   (nnmbox-possibly-change-newsgroup group server)
  341.   ;; Delete all articles in GROUP.
  342.   (if (not force)
  343.       ()                ; Don't delete the articles.
  344.     (save-excursion
  345.       (set-buffer nnmbox-mbox-buffer)
  346.       (goto-char (point-min))
  347.       ;; Delete all articles in this group.
  348.       (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
  349.         found)
  350.     (while (search-forward ident nil t)
  351.       (setq found t)
  352.       (nnmbox-delete-mail))
  353.     (when found
  354.       (save-buffer)))))
  355.   ;; Remove the group from all structures.
  356.   (setq nnmbox-group-alist
  357.     (delq (assoc group nnmbox-group-alist) nnmbox-group-alist)
  358.     nnmbox-current-group nil)
  359.   ;; Save the active file.
  360.   (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
  361.   t)
  362.  
  363. (deffoo nnmbox-request-rename-group (group new-name &optional server)
  364.   (nnmbox-possibly-change-newsgroup group server)
  365.   (save-excursion
  366.     (set-buffer nnmbox-mbox-buffer)
  367.     (goto-char (point-min))
  368.     (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
  369.       (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
  370.       found)
  371.       (while (search-forward ident nil t)
  372.     (replace-match new-ident t t)
  373.     (setq found t))
  374.       (when found
  375.     (save-buffer))))
  376.   (let ((entry (assoc group nnmbox-group-alist)))
  377.     (when entry
  378.       (setcar entry new-name))
  379.     (setq nnmbox-current-group nil)
  380.     ;; Save the new group alist.
  381.     (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
  382.     t))
  383.  
  384.  
  385. ;;; Internal functions.
  386.  
  387. ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
  388. ;; headers there are.  If LEAVE-DELIM, don't delete the Unix mbox
  389. ;; delimiter line.
  390. (defun nnmbox-delete-mail (&optional force leave-delim)
  391.   ;; Delete the current X-Gnus-Newsgroup line.
  392.   (or force
  393.       (delete-region
  394.        (progn (beginning-of-line) (point))
  395.        (progn (forward-line 1) (point))))
  396.   ;; Beginning of the article.
  397.   (save-excursion
  398.     (save-restriction
  399.       (narrow-to-region
  400.        (save-excursion
  401.      (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
  402.      (if leave-delim (progn (forward-line 1) (point))
  403.        (match-beginning 0)))
  404.        (progn
  405.      (forward-line 1)
  406.      (or (and (re-search-forward (concat "^" message-unix-mail-delimiter)
  407.                      nil t)
  408.           (if (and (not (bobp)) leave-delim)
  409.               (progn (forward-line -2) (point))
  410.             (match-beginning 0)))
  411.          (point-max))))
  412.       (goto-char (point-min))
  413.       ;; Only delete the article if no other groups owns it as well.
  414.       (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
  415.     (delete-region (point-min) (point-max))))))
  416.  
  417. (defun nnmbox-possibly-change-newsgroup (newsgroup &optional server)
  418.   (when (and server
  419.          (not (nnmbox-server-opened server)))
  420.     (nnmbox-open-server server))
  421.   (when (or (not nnmbox-mbox-buffer)
  422.         (not (buffer-name nnmbox-mbox-buffer)))
  423.     (save-excursion
  424.       (set-buffer (setq nnmbox-mbox-buffer
  425.             (nnheader-find-file-noselect
  426.              nnmbox-mbox-file nil 'raw)))
  427.       (buffer-disable-undo (current-buffer))))
  428.   (when (not nnmbox-group-alist)
  429.     (nnmail-activate 'nnmbox))
  430.   (if newsgroup
  431.       (when (assoc newsgroup nnmbox-group-alist)
  432.     (setq nnmbox-current-group newsgroup))
  433.     t))
  434.  
  435. (defun nnmbox-article-string (article)
  436.   (if (numberp article)
  437.       (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"
  438.           (int-to-string article) " ")
  439.     (concat "\nMessage-ID: " article)))
  440.  
  441. (defun nnmbox-article-group-number ()
  442.   (save-excursion
  443.     (goto-char (point-min))
  444.     (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
  445.                  nil t)
  446.       (cons (buffer-substring (match-beginning 1) (match-end 1))
  447.         (string-to-int
  448.          (buffer-substring (match-beginning 2) (match-end 2)))))))
  449.  
  450. (defun nnmbox-save-mail (group-art)
  451.   "Called narrowed to an article."
  452.   (let ((delim (concat "^" message-unix-mail-delimiter)))
  453.     (goto-char (point-min))
  454.     ;; This might come from somewhere else.
  455.     (unless (looking-at delim)
  456.       (insert "From nobody " (current-time-string) "\n")
  457.       (goto-char (point-min)))
  458.     ;; Quote all "From " lines in the article.
  459.     (forward-line 1)
  460.     (while (re-search-forward delim nil t)
  461.       (beginning-of-line)
  462.       (insert "> "))
  463.     (nnmail-insert-lines)
  464.     (nnmail-insert-xref group-art)
  465.     (nnmbox-insert-newsgroup-line group-art)
  466.     (run-hooks 'nnmail-prepare-save-mail-hook)
  467.     (run-hooks 'nnmbox-prepare-save-mail-hook)
  468.     group-art))
  469.  
  470. (defun nnmbox-insert-newsgroup-line (group-art)
  471.   (save-excursion
  472.     (goto-char (point-min))
  473.     (when (search-forward "\n\n" nil t)
  474.       (forward-char -1)
  475.       (while group-art
  476.     (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
  477.             (caar group-art) (cdar group-art)
  478.             (current-time-string)))
  479.     (setq group-art (cdr group-art))))
  480.     t))
  481.  
  482. (defun nnmbox-active-number (group)
  483.   ;; Find the next article number in GROUP.
  484.   (let ((active (cadr (assoc group nnmbox-group-alist))))
  485.     (if active
  486.     (setcdr active (1+ (cdr active)))
  487.       ;; This group is new, so we create a new entry for it.
  488.       ;; This might be a bit naughty... creating groups on the drop of
  489.       ;; a hat, but I don't know...
  490.       (push (list group (setq active (cons 1 1)))
  491.         nnmbox-group-alist))
  492.     (cdr active)))
  493.  
  494. (defun nnmbox-create-mbox ()
  495.   (when (not (file-exists-p nnmbox-mbox-file))
  496.     (nnmail-write-region 1 1 nnmbox-mbox-file t 'nomesg)))
  497.  
  498. (defun nnmbox-read-mbox ()
  499.   (nnmail-activate 'nnmbox)
  500.   (nnmbox-create-mbox)
  501.   (if (and nnmbox-mbox-buffer
  502.        (buffer-name nnmbox-mbox-buffer)
  503.        (save-excursion
  504.          (set-buffer nnmbox-mbox-buffer)
  505.          (= (buffer-size) (nnheader-file-size nnmbox-mbox-file))))
  506.       ()
  507.     (save-excursion
  508.       (let ((delim (concat "^" message-unix-mail-delimiter))
  509.         (alist nnmbox-group-alist)
  510.         start end number)
  511.     (set-buffer (setq nnmbox-mbox-buffer
  512.               (nnheader-find-file-noselect
  513.                nnmbox-mbox-file nil 'raw)))
  514.     (buffer-disable-undo (current-buffer))
  515.  
  516.     ;; Go through the group alist and compare against
  517.     ;; the mbox file.
  518.     (while alist
  519.       (goto-char (point-max))
  520.       (when (and (re-search-backward
  521.               (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
  522.                   (caar alist)) nil t)
  523.              (>= (setq number
  524.                    (string-to-number
  525.                 (buffer-substring
  526.                  (match-beginning 1) (match-end 1))))
  527.              (cdadar alist)))
  528.         (setcdr (cadar alist) (1+ number)))
  529.       (setq alist (cdr alist)))
  530.  
  531.     (goto-char (point-min))
  532.     (while (re-search-forward delim nil t)
  533.       (setq start (match-beginning 0))
  534.       (when (not (search-forward "\nX-Gnus-Newsgroup: "
  535.                      (save-excursion
  536.                        (setq end
  537.                          (or
  538.                           (and
  539.                            (re-search-forward delim nil t)
  540.                            (match-beginning 0))
  541.                           (point-max))))
  542.                      t))
  543.         (save-excursion
  544.           (save-restriction
  545.         (narrow-to-region start end)
  546.         (nnmbox-save-mail
  547.          (nnmail-article-group 'nnmbox-active-number)))))
  548.       (goto-char end))))))
  549.  
  550. (provide 'nnmbox)
  551.  
  552. ;;; nnmbox.el ends here
  553.